home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / library / tclshell.tcl < prev    next >
Encoding:
Text File  |  1993-11-05  |  4.7 KB  |  125 lines  |  [TEXT/MPS ]
  1. #----------
  2. # This file has been modified for Macintosh Tcl and Tickle. -- Tim Endres
  3. #----------
  4. #puts stdout "••• tclshell.tcl"
  5.  
  6. #
  7. # tclshell.tcl --
  8. #
  9. # Commands that are used to support an interactive Tcl shell.  These are
  10. # not called directly, but from the "unknown" command.  Much of this code
  11. # is taken directly from the UCB Tcl library/init.tcl file.
  12. #------------------------------------------------------------------------------
  13. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  14. #
  15. # Permission to use, copy, modify, and distribute this software and its
  16. # documentation for any purpose and without fee is hereby granted, provided
  17. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  18. # Mark Diekhans make no representations about the suitability of this
  19. # software for any purpose.  It is provided "as is" without express or
  20. # implied warranty.
  21. #------------------------------------------------------------------------------
  22. # Copyright (c) 1991-1993 The Regents of the University of California.
  23. # All rights reserved.
  24. #
  25. # Permission is hereby granted, without written agreement and without
  26. # license or royalty fees, to use, copy, modify, and distribute this
  27. # software and its documentation for any purpose, provided that the
  28. # above copyright notice and the following two paragraphs appear in
  29. # all copies of this software.
  30. #
  31. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  32. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  33. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  34. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35. #
  36. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  37. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  38. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  39. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  40. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  41. #------------------------------------------------------------------------------
  42. # $Id: tclshell.tcl,v 1.4 1993/08/31 23:03:20 markd Exp $
  43. #------------------------------------------------------------------------------
  44. #
  45.  
  46. #@package: TclX-shell tclx_unknown2 auto_execok
  47.  
  48. #------------------------------------------------------------------------------
  49. # tclx_unknown:
  50. # This implements the slow path of the TclX unknown command.  It must be called
  51. # directly from the unknown command.  This handles exec-ing of Unix programs
  52. # and interactive csh style redo.  Returns the result of the executed command.
  53. #
  54.  
  55. proc tclx_unknown2 {cmd} {
  56.     global tcl_interactive auto_noexec
  57.  
  58.     set name [lindex $cmd 0]
  59.  
  60.     if ![info exists auto_noexec] {
  61.         if [auto_execok $name] {
  62.             if {!$tcl_interactive || ([info level] > 2) ||
  63.                 [info script] != ""} {
  64.                 error "Auto execution of Unix commands only supported as interactive commands.\nUse \"exec\" to execute \"$name\""
  65.             }
  66.             uplevel 2 system [list $cmd]
  67.             return
  68.         }
  69.     }
  70.  
  71.     if {!$tcl_interactive || ([info level] > 2) || [info script] != ""} {
  72.         error "invalid command name \"$name\""
  73.     }
  74.  
  75.     # csh-style redo.
  76.  
  77.     if {([info level] == 2) && ([info script] == "")} {
  78.         if {$name == "!!"} {
  79.             return [uplevel {history redo}]
  80.         }
  81.         if [regexp {^!(.+)$} $name dummy event] {
  82.             return [uplevel [list history redo $event]]
  83.         }
  84.         if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  85.             return [uplevel [list history substitute $old $new]]
  86.         }
  87.         set cmds [info commands $name*]
  88.         if {[llength $cmds] == 1} {
  89.             return [uplevel [lreplace $args 0 0 $cmds]]
  90.         }
  91.         if {[llength $cmds] != 0} {
  92.             if {$name == ""} {
  93.                 return -code error "empty command name \"\""
  94.             } else {
  95.                 return -code error \
  96.                         "ambiguous command name \"$name\": [lsort $cmds]"
  97.             }
  98.         }
  99.     }
  100.     error "invalid command name \"$name\""
  101. }
  102.  
  103.  
  104. #------------------------------------------------------------------------------
  105. # auto_execok:
  106. # Returns 1 if there's an executable in the current path for the
  107. # given name, 0 otherwise.  Builds an associative array auto_execs
  108. # that caches information about previous checks, for speed.
  109.  
  110. proc auto_execok name {
  111.     global auto_execs env
  112.  
  113.     if [info exists auto_execs($name)] {
  114.         return $auto_execs($name)
  115.     }
  116.     set auto_execs($name) 0
  117.     foreach dir [split $env(PATH) :] {
  118.         if {[file executable $dir:$name] && ![file isdirectory $dir:$name]} {
  119.             set auto_execs($name) 1
  120.             return 1
  121.         }
  122.     }
  123.     return 0
  124. }
  125.